home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1997 September / Macworld (1997-09).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / misc.tcl < prev    next >
Encoding:
Text File  |  1997-04-11  |  26.8 KB  |  1,056 lines  |  [TEXT/ALFA]
  1. #===========================================================================
  2. # Information about a selection or window.
  3. #===========================================================================
  4. proc wordCount {} {
  5.     if {[set chars [expr {[selEnd] - [getPos]}]]} {
  6.         set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
  7.         set text [getSelect]
  8.     } else {
  9.         set chars [maxPos]
  10.         set lines [lindex [posToRowCol $chars] 0]
  11.         set text [getText 0 [maxPos]]
  12.     }
  13.     if {[regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " ret]} {
  14.         set words [llength $ret]
  15.     } else {
  16.         set words [llength $text]
  17.     }
  18.     alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
  19. }
  20.  
  21. #=============================================================================
  22. # Random functions.
  23. #=============================================================================
  24.  
  25. #================================================================================
  26.  
  27. proc nextFunc {} {
  28.     searchFunc 1
  29. }
  30.  
  31. proc prevFunc {} {
  32.     searchFunc 0
  33. }
  34.  
  35. proc searchFunc {dir} {
  36.     global funcExpr
  37.     set pos [getPos]
  38.     select $pos
  39.     if ($dir==1) {
  40.         incr pos
  41.     } else {
  42.         set pos [expr $pos-1]
  43.     }
  44.     if {![catch {search -s -f $dir -i 1 -r 1 $funcExpr $pos} res]} {
  45.         eval select $res
  46.     }
  47. }
  48.  
  49. #===========================================================================
  50. # Comment routines.
  51. #===========================================================================
  52. proc commentPara {} {
  53. }
  54.  
  55.  
  56.  
  57. #===========================================================================
  58. # Sorting the selection.
  59. # AUTHOR: David C. Black     black@mpd.tandem.com
  60. #===========================================================================
  61. proc sortLines {} {
  62.     set ends [getEndpts]
  63.     set start [lindex $ends 0]
  64.     set end  [lindex $ends 1]
  65.     if {$start == $end} {
  66.         alertnote "You must highlight the section you wish to sort."
  67.         return
  68.     }
  69.     if {[lookAt [expr $end-1]] != "\r"} {
  70.         alertnote "The selection must consist only of complete lines."
  71.         return
  72.     }
  73.     set text [getText $start [expr {$end-1}]]
  74.     set text [join [lsort [split $text "\r"]] "\r"]
  75.     replaceText $start [expr {$end-1}] $text
  76.     select $start $end
  77. }
  78.  
  79.  
  80.  
  81. #===========================================================================
  82. # Dump all current settings into a file.
  83. #===========================================================================
  84. proc insertGlobalSettings {} {
  85.     uplevel #0 {
  86.         foreach var [info globals] {
  87.             if {![catch {set $var}]} {
  88.                 insertText "set " $var " \{" [set $var] "\}\r"
  89.             }
  90.         }
  91.     }
  92. }
  93.  
  94.  
  95. #================================================================================
  96. # Substitute global variables in possibly nested list.
  97. #================================================================================
  98. proc subVars {words} {
  99.     global silly
  100.     global a
  101.     set silly $words
  102.     set out {}
  103.     foreach a $words {
  104.         if {[llength $a] == 1} {
  105.             lappend out [uplevel #0 {eval set x $a}]
  106.         } else {
  107.             lappend out [subVars $a]
  108.         }
  109.     }
  110.     return $out
  111. }
  112.  
  113. #================================================================================
  114. # Block shift left and right.
  115. #================================================================================
  116.  
  117. proc shiftLeft {} {
  118.     global shiftChar
  119.     doShiftLeft "\t"
  120.     
  121. }
  122. proc shiftLeftSpace {} {
  123.     global shiftChar
  124.     doShiftLeft " "
  125. }
  126.  
  127. proc doShiftLeft {shiftChar} {
  128.      set start [lineStart [getPos]]
  129.      set end [nextLineStart [expr [selEnd] - 1]]
  130.     if {$start >= $end} {set end [nextLineStart $start]}
  131.     
  132.     set text [split [getText $start [expr $end - 1]] "\r"]
  133.     
  134.     set textout ""
  135.     
  136.     foreach line $text {
  137.         if {[string index $line 0] == $shiftChar} {
  138.             lappend textout [string range $line 1 end]
  139.         } else {
  140.             lappend textout $line
  141.         }
  142.     }
  143.  
  144.     set text [join $textout "\r"]    
  145.     replaceText $start [expr $end - 1] $text
  146.     select $start [expr 1 + $start + [string length $text]]
  147. }
  148.  
  149.  
  150. proc shiftRight {} {
  151.     global shiftChar
  152.     doShiftRight "\t"
  153.     
  154. }
  155. proc shiftRightSpace {} {
  156.     global shiftChar
  157.     doShiftRight " "
  158. }
  159. proc doShiftRight {shiftChar} {
  160.     set start [lineStart [getPos]]
  161.     set end [nextLineStart [expr [selEnd] - 1]]
  162.     if {$start >= $end} {set end [nextLineStart $start]}
  163.     
  164.     set text [split [getText $start [expr $end - 1]] "\r"]
  165.     
  166.     set textout ""
  167.     
  168.     foreach line $text {
  169.         lappend textout $shiftChar$line
  170.     }
  171.     
  172.     set text [join $textout "\r"]    
  173.     replaceText $start [expr $end - 1] $text
  174.     select $start [expr 1 + $start + [string length $text]]
  175. }
  176.  
  177.  
  178.  
  179. # rglobText [option list] dir pat
  180. # 'dir' should be a properly formed directory, ending w/ a ':'. 'pat' should be 
  181. # a simple pattern w/ no directory specifications (i.e. "*.c").
  182. proc rglobText {optlist dir pat} {
  183.  
  184.     message "$dir"
  185.     set cmd [concat glob -t TEXT $optlist]
  186.     lappend cmd $dir$pat
  187.     if {[catch {eval $cmd} files]} {
  188.         set files ""
  189.     }
  190.     
  191.     if {![catch {glob $dir*} all]} {
  192.         foreach f $all {
  193.             if {[file isdir $f]} {
  194.                 set files [concat $files [rglobText $optlist $f: $pat]]
  195.             }
  196.         }
  197.     }
  198.     return $files
  199. }
  200.  
  201.  
  202. proc switchApp {} {
  203.     set procs ""
  204.     foreach p [processes] {
  205.         lappend procs [lindex $p 0]
  206.     }
  207.     set to [listpick -p "Switch to app:" [lsort $procs]]
  208.     if {[string length $to]} {
  209.         switchTo $to
  210.     }
  211. }
  212.  
  213.  
  214. proc selectAll {} {
  215.     select 0 [maxPos]
  216. }
  217.  
  218.  
  219. proc twiddle {} {
  220.     set pos [getPos]
  221.     if {!$pos || ($pos == [maxPos])} return;
  222.     if {[string length [set text [getSelect]]]} {
  223.         if {[string length $text] == 1} {
  224.             return
  225.         } else {
  226.             set sel [expr [selEnd] - 1]
  227.             set one [lookAt $sel]
  228.             set two [lookAt $pos]
  229.             replaceText $pos [expr $sel + 1] "$one[getText [expr $pos+1] $sel]$two"
  230.             select $pos [expr $sel+1]
  231.             return
  232.         }
  233.     }
  234.     set one [lookAt $pos]
  235.     set two [lookAt [expr $pos-1]]
  236.     replaceText [expr $pos-1] [expr $pos + 1] "$one$two"
  237.     select  [expr $pos-1] [expr $pos + 1]
  238. }
  239.  
  240. proc twiddleWords {} {
  241.     global wordBreakPreface wordBreak
  242.  
  243.     if {[getPos] != [selEnd]} {
  244.         set start1 [getPos]; set end2 [selEnd]
  245.         select $start1
  246.         forwardWord; set end1 [getPos]
  247.         goto $end2
  248.         backwardWord; set start2 [getPos]
  249.     } else {
  250.         select [set pos [getPos]]
  251.         backwardWord; set start1 [getPos]
  252.         forwardWord; set end1 [getPos]
  253.         goto $pos
  254.         forwardWord; set end2 [getPos]
  255.         backwardWord; set start2 [getPos]
  256.     }        
  257.  
  258.     if {$start1 != $start2} {
  259.         set mid [getText $end1 $start2]
  260.         replaceText $start1 $end2 "[getText $start2 $end2]$mid[getText $start1 $end1]"
  261.         select $start1 $end2
  262.     }
  263. }
  264.  
  265. #================================================================================
  266. # Print a window using John Cho's Enscriptor (A text file printing app that
  267. # works like Adobe Enscript.)
  268. #
  269.  
  270. proc setupPrintMenu {} {
  271.     global pathComments defaultPrinter modifiedVars
  272.     if {![info exists defaultPrinter]} {
  273.         set defaultPrinter "Alpha"
  274.         lappend modifiedVars defaultPrinter
  275.     }
  276.     set m [list {/P<SPrint…} {/P<S<I<OPrint All…} {(-} Alpha Kodex Enscriptor {Drop•PS} PrettyC]
  277.     menu -m -n print -p printProc $m
  278.     
  279.     foreach item $m {
  280.         if {$item == $defaultPrinter} {
  281.             markMenuItem -m print $item on
  282.         } else {
  283.             markMenuItem -m print $item off
  284.         }
  285.     }
  286. }
  287.  
  288. proc printProc {menu item} {
  289.     global modifiedVars defaultPrinter pathComments
  290.     switch -glob $item {
  291.         "Print All"        {    if {$defaultPrinter == "Alpha"} {
  292.                                 printAll
  293.                             } else {
  294.                                 foreach f [winNames -f] {
  295.                                     printFile $f
  296.                                 }
  297.                             }
  298.                         }
  299.         "Print"            {printFile [car [winNames -f]]}
  300.         default            {set defaultPrinter $item; lappend modifiedVars defaultPrinter; setupPrintMenu}
  301.     }
  302. }
  303.  
  304.  
  305. proc printFile {fname} {
  306.     global defaultPrinter
  307.     
  308.     switch -glob $defaultPrinter {
  309.         "Alpha"            {print}
  310.         "Kodex*"        {openAndSendFile KoDX}
  311.         "Enscr*"        {openAndSendFile Ens3}
  312.         "Drop*"            {openAndSendFile {D•PS}}
  313.         "Pret*"            {openAndSendFile niCe}
  314.     }
  315. }
  316.  
  317.  
  318. proc commentBox {} {
  319.  
  320. # Preliminaries
  321.     if [commentGetRegion Box] { return }
  322.     
  323.     set commentList [commentCharacters Box]
  324.     if { [llength $commentList] == 0 } { return }
  325.     
  326.     set begComment [lindex $commentList 0]
  327.     set begComLen [lindex $commentList 1]
  328.     set endComment [lindex $commentList 2]
  329.     set endComLen [lindex $commentList 3]
  330.     set fillChar [lindex $commentList 4]
  331.     set spaceOffset [lindex $commentList 5]
  332.  
  333.     set aSpace " "
  334.  
  335. # First make sure we grab a full block of lines and adjust highlight
  336.  
  337.     set start [getPos]
  338.     set start [lineStart $start]
  339.     set end [selEnd]
  340.     set end [nextLineStart [expr $end-1]]
  341.     select $start $end
  342.  
  343. # Now get rid of any tabs
  344.     
  345.     if { $end < [maxPos] } then {
  346.         createTMark stopComment [expr $end+1]
  347.         tabsToSpaces
  348.         gotoTMark stopComment
  349.         set end [expr [getPos]-1]
  350.         removeTMark stopComment
  351.     } else {
  352.         tabsToSpaces
  353.         set end [maxPos]
  354.     }
  355.     select $start $end
  356.     set text [getText $start $end]
  357.     
  358. # Next turn it into a list of lines--possibly drop an empty 'last line'
  359.  
  360. # VMD May'95: changed this code segment because it
  361. # previously had problems with empty lines in the
  362. # middle of the text to be commented
  363.  
  364.     set lineList [split $text "\r"]
  365.     set ll [llength $lineList]
  366.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  367.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  368.     }
  369.     set numLines [llength $lineList]
  370.  
  371. # end changes.
  372.     
  373. # Find the longest line length and determine the new line length
  374.  
  375.     set maxLength 0
  376.     foreach thisLine $lineList {
  377.         set thisLength [string length $thisLine]
  378.         if { $thisLength > $maxLength } then { 
  379.             set maxLength $thisLength 
  380.         }
  381.     }
  382.     set newLength [expr {$maxLength + 2 + 2*$spaceOffset}]
  383.     
  384. # Now create the top & bottom bars and a blank line
  385.  
  386.     set topBar $begComment
  387.     for { set i 0 } { $i < [expr {$newLength - $begComLen}] } { incr i } {
  388.         set topBar $topBar$fillChar
  389.     }
  390.     set botBar ""
  391.     for { set i 0 } { $i < [expr {$newLength - $endComLen}] } { incr i } {
  392.         set botBar $botBar$fillChar
  393.     }
  394.     set botBar $botBar$endComment
  395.     set blankLine $fillChar
  396.     for { set i 0 } { $i < [expr {$newLength - 2}] } { incr i } {
  397.         set blankLine $blankLine$aSpace
  398.     }
  399.     set blankLine $blankLine$fillChar
  400.     
  401. # For each line add stuff on left and spaces and stuff on right for box sides
  402. # and concatenate everything into 'text'.  Start with topBar; end with botBar
  403.  
  404.     set text $topBar\r$blankLine\r
  405.     
  406.     set frontStuff $fillChar
  407.     set backStuff $fillChar
  408.     for { set i 0 } { $i < $spaceOffset } { incr i } {
  409.         set frontStuff $frontStuff$aSpace  
  410.         set backStuff $aSpace$backStuff
  411.     }
  412.     set backStuffLen [string length $backStuff]
  413.     
  414.     for { set i 0 } { $i < $numLines } { incr i } {
  415.         set thisLine [lindex $lineList $i ]
  416.         set thisLine $frontStuff$thisLine
  417.         set thisLength [string length $thisLine]
  418.         set howMuchPad [expr {$newLength - $thisLength - $backStuffLen}]
  419.         for { set j 0 } { $j < $howMuchPad } { incr j } {
  420.             set thisLine $thisLine$aSpace 
  421.         }
  422.         set thisLine $thisLine$backStuff
  423.         set text $text$thisLine\r
  424.     }
  425.     
  426.     set text $text$blankLine\r$botBar\r
  427.     
  428. # Now replace the old stuff, turn spaces to tabs, and highlight
  429.  
  430.     replaceText    $start $end    $text
  431.     set    end    [expr {$start+[string length $text]}]
  432.     cleverSpacesToTabs $start $end
  433. }
  434.  
  435. proc uncommentBox {} {
  436.  
  437. # Preliminaries
  438.     if [commentGetRegion Box 1] { return }
  439.     
  440.     set commentList [commentCharacters Box]
  441.     if { [llength $commentList] == 0 } { return }
  442.     
  443.     set    begComment [lindex $commentList    0]
  444.     set    begComLen [lindex $commentList 1]
  445.     set    endComment [lindex $commentList    2]
  446.     set    endComLen [lindex $commentList 3]
  447.     set    fillChar [lindex $commentList 4]
  448.     set    spaceOffset    [lindex    $commentList 5]
  449.  
  450.     set aSpace " "
  451.     set aTab \t
  452.  
  453. # First make sure we grab a full block of lines
  454.  
  455.     set start [getPos]
  456.     set start [lineStart $start]
  457.     set end [selEnd]
  458.     set end [nextLineStart [expr $end-1]]
  459.     set text [getText $start $end]
  460.  
  461. # Make sure we're at the start and end of the box
  462.  
  463.     set startOK [string first $begComment $text]
  464.     set endOK [string last $endComment $text]
  465.     set textLength [string length $text]
  466.     if { $startOK != 0 || ($endOK != [expr {$textLength-$endComLen-1}] || $endOK == -1) } then {
  467.         alertnote "You must highlight the entire comment box, including the borders."
  468.         return
  469.     }
  470.     
  471. # Now get rid of any tabs
  472.     
  473.     if { $end < [maxPos] } then {
  474.         createTMark stopComment [expr $end+1]
  475.         tabsToSpaces
  476.         gotoTMark stopComment
  477.         set end [expr [getPos]-1]
  478.         removeTMark stopComment
  479.     } else {
  480.         tabsToSpaces
  481.         set end [maxPos]
  482.     }
  483.     select $start $end
  484.     set text [getText $start $end]
  485.     
  486. # Next turn it into a list of lines--possibly drop an empty 'last line'
  487.  
  488. # VMD May'95: changed this code segment because it
  489. # previously had problems with empty lines in the
  490. # middle of the text to be commented
  491.  
  492.     set lineList [split $text "\r"]
  493.     set ll [llength $lineList]
  494.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  495.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  496.     }
  497.     set numLines [llength $lineList]
  498.  
  499. # end changes.
  500.     
  501. # Delete the first and last lines, recompute number of lines
  502.  
  503.     set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  504.     set lineList [lreplace $lineList 0 0 ]
  505.     set numLines [llength $lineList]
  506.     
  507. # Eliminate 2nd and 2nd-to-last lines if they are empty
  508.  
  509.     set eliminate $fillChar$aSpace$aTab
  510.     set thisLine [lindex $lineList [expr $numLines-1]]
  511.     set thisLine [string trim $thisLine $eliminate]
  512.     if { [string length $thisLine] == 0 } then {
  513.         set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  514.     }
  515.     set thisLine [lindex $lineList 0]
  516.     set thisLine [string trim $thisLine $eliminate]
  517.     if { [string length $thisLine] == 0 } then {
  518.         set lineList [lreplace $lineList 0 0 ]
  519.     }
  520.     set numLines [llength $lineList]    
  521.     
  522. # For each line trim stuff on left and spaces and stuff on right and splice
  523.  
  524.     set dropFromLeft [expr $spaceOffset+1]
  525.     set text ""
  526.     for { set i 0 } { $i < $numLines } { incr i } {
  527.         set thisLine [lindex $lineList $i]
  528.         set thisLine [string trimright $thisLine $eliminate]
  529.         set thisLine [string range $thisLine $dropFromLeft end]
  530.         set text $text$thisLine\r
  531.     }
  532.         
  533. # Now replace the old stuff, convert spaces back to tabs
  534.  
  535.     replaceText    $start $end    $text
  536.     set end [expr {$start+[string    length $text]}]
  537.     cleverSpacesToTabs $start $end
  538. }
  539.  
  540. proc commentCharacters { purpose } {
  541.     global mode
  542.     
  543.     switch $purpose {
  544.         "Paragraph" {        
  545.             switch $mode {
  546.                 "TeX" {return [list "%% " " %%" " % "] }
  547.                 "Text" {return [list "!! " " !!" " ! "] }
  548.                 "Fort" {return [list "c " "c " "c "] }
  549.                 "Tcl" {return [list "## " " ##" " # "] }
  550.                 "Perl" {return [list "# " "# " "# "] }
  551.                 "C" {return [list "/* " " */" " * "] }
  552.                 "C++" {return [list "/* " " */" " * "] }
  553.                 default {
  554.                     alertnote "I don't know what comments should look like in this mode.  Sorry."
  555.                     return
  556.                 }
  557.             }
  558.         }
  559.         "Box" {
  560.         switch $mode {
  561.                 "TeX" {return [list "%" 1 "%" 1 "%" 3] }
  562.                 "Text" {return [list "!" 1 "!" 1 "!" 3] }
  563.                 "Fort" {return [list "c" 1 "c" 1 "c" 3] }
  564.                 "Tcl" {return [list "#" 1 "#" 1 "#" 3] }
  565.                 "Perl" {return [list "#" 1 "#" 1 "#" 3] }
  566.                 "C" {return [list "/*" 2 "*/" 2 "*" 3] }
  567.                 "C++" {return [list "/*" 2 "*/" 2 "*" 3] }
  568.                 default {
  569.                     alertnote "I don't know what comments should look like in this mode.  Sorry."
  570.                     return
  571.                 }
  572.             }    
  573.         }
  574.     }    
  575.  
  576. }
  577.  
  578. ## 
  579.  # Default is to look for a    paragraph to comment out.
  580.  # If sent '1',    then we    look for a commented region    to 
  581.  # uncomment.
  582.  ##
  583. proc commentGetRegion { purpose {uncomment 0 } } {
  584.     if {[getPos] != [selEnd]} {
  585.         watchCursor
  586.         return 0    
  587.     }
  588.  
  589.     # there's no selection, so we try and generate one
  590.     
  591.     set pos [getPos]
  592.     if $uncomment {
  593.         # uncommenting
  594.         set commentList [commentCharacters $purpose]
  595.         if { [llength $commentList] == 0 } { return 1}
  596.         switch $purpose {
  597.             "Box" {
  598.                 set begComment [lindex $commentList 0]
  599.                 set begComLen [lindex $commentList 1]
  600.                 set endComment [lindex $commentList 2]
  601.                 set endComLen [lindex $commentList 3]
  602.                 set fillChar [lindex $commentList 4]
  603.                 set spaceOffset [lindex $commentList 5]
  604.                 
  605.                 # get length of current line
  606.                 set line [getText [lineStart $pos] [nextLineStart $pos] ]
  607.                 set c [string trimleft $line]
  608.                 set slen [expr [string length $line] - [string length $c] ]
  609.                 set start [string range $line 0 [expr $slen -1 ] ]
  610.                 
  611.                 set pos [getPos]
  612.                 
  613.                 if { $start == "" } {
  614.                     set p $pos
  615.                     while { [string first $fillChar $line] == 0 && \
  616.                         [expr [string last $fillChar $line] + [string length $fillChar]] \
  617.                         >= [string length [string trimright $line]] } {
  618.                         set p [nextLineStart $p]
  619.                         set line [getText [lineStart $p] [nextLineStart $p]]
  620.                     }
  621.                     set end [lineStart $p]
  622.                     
  623.                     set p $pos
  624.                     set line "${fillChar}"
  625.                     while { [string first $fillChar $line] == 0 && \
  626.                         [expr [string last $fillChar $line] + [string length $fillChar]] \
  627.                         >= [string length [string trimright $line]] } {
  628.                         set p [prevLineStart $p]
  629.                         set line [getText [prevLineStart $p] [lineStart $p] ]
  630.                     }
  631.                     set begin [prevLineStart $p]
  632.                     
  633.                 } else {
  634.                     set line "$start"
  635.                     set p $pos
  636.                     while { [string range $line 0 [expr $slen -1] ] == "$start" } {
  637.                         set p [nextLineStart $p]
  638.                         set line [getText [lineStart $p] [nextLineStart $p]]
  639.                     }
  640.                     set end [prevLineStart $p]
  641.                     
  642.                     set p $pos
  643.                     set line "$start"
  644.                     while { [string range $line 0 [expr $slen -1] ] == "$start" } {
  645.                         set p [prevLineStart $p]
  646.                         set line [getText [prevLineStart $p] [lineStart $p] ]
  647.                     }
  648.                     set begin [lineStart $p]
  649.                 }
  650.  
  651.                 set beginline [getText $begin [nextLineStart  $begin]]
  652.                 if { [string first "$begComment" "$beginline" ] != $slen } {
  653.                     message "First line failed"
  654.                     return 1
  655.                 }
  656.                 
  657.                 set endline [getText $end [nextLineStart $end]]
  658.                 set epos [string last "$endComment" "$endline"]
  659.                 incr epos [string length $endComment]
  660.                 set s [string range $endline $epos end ]
  661.                 set s [string trimright $s]
  662.                 
  663.                 if { $s != "" } {
  664.                     message "Last line failed"
  665.                     return 1
  666.                 }
  667.                 
  668.                 set end [nextLineStart $end]
  669.                 select $begin $end
  670.                 #alertnote "Sorry auto-box selection not yet implemented"
  671.             }
  672.             "Paragraph" {
  673.                 set begComment [lindex $commentList 0]
  674.                 set endComment [lindex $commentList 1]
  675.                 set fillChar [lindex $commentList 2]
  676.                 
  677.                 ## 
  678.                  # basic idea is search    back and forwards for lines
  679.                  # that    don't begin    the    same way and then see if they
  680.                  # match the idea of the beginning and end of a    block
  681.                  ##
  682.                 
  683.                 set line [getText [lineStart $pos] [nextLineStart $pos] ]
  684.                 set chk [string range $line 0 [string first $fillChar $line]]
  685.                 if { [string trimleft $chk] != "" } {
  686.                     message "Not in a comment block"
  687.                     return 1
  688.                 }
  689.                 regsub -all {    } $line " " line
  690.                 set p [string first "$fillChar" "$line"]
  691.                 set start [string range "$line" 0 [expr $p + [string length $fillChar] -1 ]]
  692.                 set ll [commentGetFillLines $start]
  693.                 set begin [lindex $ll 0]
  694.                 set end [lindex $ll 1]
  695.                 
  696.                 set beginline [getText $begin [nextLineStart  $begin]]
  697.                 if { [string first "$begComment" "$beginline" ] != $p } {
  698.                     message "First line failed"
  699.                     return 1
  700.                 }
  701.                 
  702.                 set endline [getText $end [nextLineStart $end]]
  703.                 set epos [string last "$endComment" "$endline"]
  704.                 incr epos [string length $endComment]
  705.                 set s [string range $endline $epos end ]
  706.                 set s [string trimright $s]
  707.                 
  708.                 if { $s != "" } {
  709.                     message "Last line failed"
  710.                     return 1
  711.                 }
  712.                 #goto $end
  713.                 set end [nextLineStart $end]
  714.                 select $begin $end
  715.             }
  716.         }
  717.     } else {
  718.         # commenting out
  719.         set searchString {^[ \t]*$}
  720.         set searchResult1 [search -s -f 0 -r 1 -n $searchString $pos]
  721.         set searchResult2 [search -s -f 1 -r 1 -n $searchString $pos]
  722.         if {[llength $searchResult1]} then {
  723.             set posStart [expr [lindex $searchResult1 1] +1]
  724.         } else {
  725.             set posStart 0
  726.         }
  727.         if {[llength $searchResult2]} then {
  728.             set posEnd [lindex $searchResult2 0]
  729.         } else {
  730.             set posEnd [expr [maxPos] +1]
  731.             goto [maxPos]
  732.             insertText "\n"
  733.         }
  734.         select $posStart $posEnd
  735.     }
  736.     
  737.      set str "Do you wish to "
  738.      if $uncomment { append str "uncomment" } else { append str "comment out" }
  739.      append str " this region?"
  740.     if { [askyesno $str] == "yes" } {
  741.         return 0
  742.     } else {
  743.         return 1
  744.     }
  745. }
  746.  
  747.  
  748. proc prevLineStart { pos } {
  749.     return [lineStart [expr [lineStart $pos]-1]]
  750. }
  751.  
  752. proc commentSameStart { line start } {
  753.     regsub -all {    } "$line" " " line
  754.     if { [string first "$start" "$line"] == 0 } {
  755.         return 1
  756.     } else {
  757.         return 0
  758.     }
  759. }
  760.  
  761. proc commentGetFillLines { start } {
  762.     set pos [getPos]
  763.     regsub -all {[\t]} $start " " start
  764.     set line "$start"
  765.     
  766.     set p $pos
  767.     while { [commentSameStart "$line" "$start"] } {
  768.         set p [nextLineStart $p]
  769.         set line [getText [lineStart $p] [nextLineStart $p]]
  770.     }
  771.     set end [lineStart $p]
  772.     
  773.     set p $pos
  774.     set line "$start"
  775.     while { [commentSameStart "$line" "$start"] } {
  776.         set p [prevLineStart $p]
  777.         set line [getText [prevLineStart $p] [lineStart $p] ]
  778.     }
  779.     set begin [prevLineStart $p]
  780.     return [list $begin $end]
  781. }
  782.  
  783. ## 
  784.  # Author: Vince Darley    <mailto:vince@das.harvard.edu> 
  785.  ##
  786.  
  787. proc commentParagraph {} {
  788.  
  789. # Preliminaries
  790.     if [commentGetRegion Paragraph] { return }
  791.     
  792.     set commentList [commentCharacters Paragraph]
  793.     if { [llength $commentList] == 0 } { return }
  794.     
  795.     set begComment [lindex $commentList 0]
  796.     set endComment [lindex $commentList 1]
  797.     set fillChar [lindex $commentList 2]
  798.     
  799.  
  800. # First make sure we grab a full block of lines and adjust highlight
  801.  
  802.     set start [getPos]
  803.     set start [lineStart $start]
  804.     set end [selEnd]
  805.     set end [nextLineStart [expr $end-1]]
  806.     select $start $end
  807.  
  808. # Now get rid of any tabs
  809.     
  810.     if { $end < [maxPos] } then {
  811.         createTMark stopComment [expr $end+1]
  812.         tabsToSpaces
  813.         gotoTMark stopComment
  814.         set end [expr [getPos]-1]
  815.         removeTMark stopComment
  816.     } else {
  817.         tabsToSpaces
  818.         set end [maxPos]
  819.     }
  820.     select $start $end
  821.     set text [getText $start $end]
  822.     
  823. # Next turn it into a list of lines--possibly drop an empty 'last line'
  824.  
  825.     set lineList [split $text "\r"]
  826.     set ll [llength $lineList]
  827.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  828.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  829.     }
  830.     set numLines [llength $lineList]
  831.  
  832. # Find left margin for these lines
  833.     set lmargin 100
  834.     for { set i 0 } { $i < $numLines } { incr i } {
  835.         set l [lindex $lineList $i]
  836.         set lm [expr [string length $l] - [string length [string trimleft $l]]]
  837.         if { $lm < $lmargin } { set lmargin $lm }
  838.     }
  839.     set ltext ""
  840.     for { set i 0 } { $i < $lmargin } { incr i } {
  841.         append ltext " "
  842.     }
  843.     
  844. # For each line add stuff on left and concatenate everything into 'text'. 
  845.  
  846.     set text ${ltext}${begComment}\r
  847.     
  848.     for { set i 0 } { $i < $numLines } { incr i } {
  849.         append text ${ltext}${fillChar}[string range [lindex $lineList $i ] $lmargin end]\r
  850.     }
  851.     append text ${ltext}${endComment}\r
  852.     
  853. # Now replace the old stuff, turn spaces to tabs, and highlight
  854.  
  855.     replaceText    $start $end    $text
  856.     set    end    [expr {$start+[string length $text]}]
  857.     cleverSpacesToTabs $start $end
  858. }
  859.  
  860. ## 
  861.  # Author: Vince Darley    <mailto:vince@das.harvard.edu> 
  862.  ##
  863.  
  864. proc uncommentParagraph {} {
  865.  
  866. # Preliminaries
  867.     if [commentGetRegion Paragraph 1] { return }
  868.     
  869.     set commentList [commentCharacters Paragraph]
  870.     if { [llength $commentList] == 0 } { return }
  871.     
  872.     set begComment [lindex $commentList 0]
  873.     set endComment [lindex $commentList 1]
  874.     set fillChar [lindex $commentList 2]
  875.  
  876.     set aSpace " "
  877.     set aTab \t
  878.  
  879. # First make sure we grab a full block of lines and adjust highlight
  880.  
  881.     set start [getPos]
  882.     set start [lineStart $start]
  883.     set end [selEnd]
  884.     set end [nextLineStart [expr $end-1]]
  885.     select $start $end
  886.     set text [getText $start $end]
  887.  
  888. # Find left margin for these lines
  889.     set l [string range $text 0 [string first "\r" $text] ]
  890.     set lmargin [expr [string length $l] - [string length [string trimleft $l]]]
  891.  
  892. # Make sure we're at the start and end of the paragraph
  893.  
  894.     set startOK [string first $begComment $text]
  895.     set endOK [string last $endComment $text]
  896.     set textLength [string length $text]
  897.     if { $startOK != $lmargin || ($endOK != [expr {$textLength-[string length $endComment]-1}] || $endOK == -1) } then {
  898.         alertnote "You must highlight the entire comment paragraph, including the tail ends."
  899.         return
  900.     }
  901.  
  902. # Now get rid of any tabs
  903.     
  904.     if { $end < [maxPos] } then {
  905.         createTMark stopComment [expr $end+1]
  906.         tabsToSpaces
  907.         gotoTMark stopComment
  908.         set end [expr [getPos]-1]
  909.         removeTMark stopComment
  910.     } else {
  911.         tabsToSpaces
  912.         set end [maxPos]
  913.     }
  914.     select $start $end
  915.     set text [getText $start $end]
  916.     
  917. # Next turn it into a list of lines--possibly drop an empty 'last line'
  918.  
  919.     set lineList [split $text "\r"]
  920.     set ll [llength $lineList]
  921.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  922.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  923.     }
  924.     set numLines [llength $lineList]
  925.     
  926. # Delete the first and last lines, recompute number of lines
  927.  
  928.     set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  929.     set lineList [lreplace $lineList 0 0 ]
  930.     set numLines [llength $lineList]
  931.  
  932. # get the left margin
  933.     set lmargin [string first $fillChar [lindex $lineList 0]]
  934.     set ltext ""
  935.     for { set i 0 } { $i < $lmargin } { incr i } {
  936.         append ltext " "
  937.     }
  938.  
  939. # For each line trim stuff on left and spaces and stuff on right and splice
  940.     set eliminate $fillChar$aSpace$aTab
  941.     set dropFromLeft [expr [string length $fillChar] + $lmargin]
  942.     set text ""
  943.     for { set i 0 } { $i < $numLines } { incr i } {
  944.         set thisLine [lindex $lineList $i]
  945.         set thisLine [string trimright $thisLine $eliminate]
  946.         set thisLine ${ltext}[string range $thisLine $dropFromLeft end]
  947.         set text $text$thisLine\r
  948.     }
  949.     
  950. # Now replace the old stuff, turn spaces to tabs, and highlight
  951.  
  952.  
  953.     replaceText    $start $end    $text
  954.     set    end    [expr {$start+[string length $text]}]
  955.     cleverSpacesToTabs $start $end
  956. }
  957.  
  958.  
  959. proc cleverTabsToSpaces { start end } {
  960.     cleverSpacesTabs tabsToSpaces $start $end
  961. }
  962.  
  963. proc cleverSpacesToTabs { start end } {
  964.     cleverSpacesTabs spacesToTabs $start $end
  965. }
  966.  
  967. proc cleverSpacesTabs { fn start end } {
  968.    set e [expr $end+1]
  969.    if { $e > [maxPos] } { 
  970.        goto $end
  971.        openLine
  972.    }
  973.    createTMark stopComment $e
  974.    select $start $end
  975.    $fn
  976.    gotoTMark stopComment
  977.    set end [expr [getPos]-1]
  978.    removeTMark stopComment
  979.    return [list $start $end]
  980. }
  981.  
  982. #===============================================================================
  983.  
  984. proc stripNameCount str {
  985.     regsub { <\d+>} $str {} str
  986.     return $str
  987. }
  988.  
  989. #===============================================================================
  990.  
  991. # Used to create a popup of all funcs in window. Routine 
  992. # should return list containing, consecutively, proc name and
  993. # start of definition. 
  994. proc parseFuncsAlpha {} {
  995.     global mode sortFuncsMenu
  996.     
  997.     if {[info procs "parseFuncs$mode"] != ""} {
  998.         return [parseFuncs$mode]
  999.     } else {
  1000.         global funcExpr parseExpr
  1001.         
  1002.         set pos 0
  1003.         if $sortFuncsMenu {
  1004.             while {[set res [search -s -f 1 -r 1 -i 0 -n $funcExpr $pos]] != ""} {
  1005.                 if {[regexp $parseExpr [getText [car $res] [cadr $res]] dummy word]} {
  1006.                     lappend m [list $word [car $res]]
  1007.                 }
  1008.                 set pos [cadr $res]
  1009.             }
  1010.             regsub -all "\[\{\}\]" [lsort -ignore $m] "" m
  1011.         } else {
  1012.             while {[set res [search -s -f 1 -r 1 -i 0 -n $funcExpr $pos]] != ""} {
  1013.                 if {[regexp $parseExpr [getText [car $res] [cadr $res]] dummy word]} {
  1014.                     lappend m $word [car $res]
  1015.                 }
  1016.                 set pos [cadr $res]
  1017.             }
  1018.         }
  1019.         return $m
  1020.     }
  1021. }
  1022.  
  1023.  
  1024. proc gotoFunc {} {
  1025.     set l [parseFuncsAlpha]
  1026.     if {[set ind [lsearch $l {(-}]] >= 0} {
  1027.         set l [lrange $l [expr $ind + 2] end]
  1028.     }
  1029.     
  1030.     while {[llength $l] > 1} {
  1031.         lappend names [car $l]
  1032.         lappend positions [cadr $l]
  1033.         set l [cddr $l]
  1034.     }
  1035.     
  1036.     set res [listpick -p "Func:" $names]
  1037.     if {[set ind [lsearch $names $res]] >= 0} {
  1038.         goto [lindex $positions $ind]
  1039.     }
  1040. }
  1041.  
  1042.  
  1043.  
  1044. proc floatName {str} {
  1045.     if {[string match "•*" $str]} {
  1046.         foreach n [info globals {*Menu}] {
  1047.             global $n
  1048.             if {![catch {set $n}] && ([set $n] == $str)} {
  1049.                 regexp {(.*)Menu} $n dummy name
  1050.                 return "[string toup [string index $name 0]][string range $name 1 end]"
  1051.             }
  1052.         }
  1053.     }
  1054.     return "[string toup [string index $str 0]][string range $str 1 end]"
  1055. }
  1056.